home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / schemify.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  126 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; schemify
  4.  
  5.  
  6. ; Flush nodes and generated names in favor of something a little more
  7. ; readable.  Eventually, (schemify node) ought to produce an
  8. ; s-expression that has the same semantics as node, when node is fully
  9. ; expanded.
  10.  
  11. (define (schemify node . env-option)
  12.   (schemify1 node (if (null? env-option) #f (car env-option))))
  13.  
  14. (define (schemify1 node env)
  15.   (if (node? node)
  16.       (or (node-ref node 'schemify)
  17.       (let ((form ((operator-table-ref schemifiers (node-operator-id node))
  18.                node env)))
  19.         (node-set! node 'schemify form)
  20.         form))
  21.       (schemify-sexp node env)))
  22.  
  23. (define schemifiers
  24.   (make-operator-table (lambda (node env)
  25.              (let ((form (node-form node)))
  26.                (if (list? form)
  27.                    (map (lambda (f) (schemify1 f env)) form)
  28.                    form)))))
  29.  
  30. (define (define-schemifier name type proc)
  31.   (operator-define! schemifiers name type proc))
  32.  
  33. (define-schemifier 'name 'leaf
  34.   (lambda (node env)
  35.     (name->qualified (node-form node) env)))
  36.  
  37. (define-schemifier 'quote syntax-type
  38.   (lambda (node env)
  39.     (let ((form (node-form node)))
  40.       (list (schemify1 (car form) env) (cadr form)))))
  41.  
  42. ; Convert an alias (generated name) to S-expression form ("qualified name").
  43. ;
  44. ; As an optimization, we elide intermediate steps in the lookup path
  45. ; when possible.  E.g.
  46. ;     #(>> #(>> #(>> define-record-type define-accessors)
  47. ;        define-accessor)
  48. ;       record-ref)
  49. ; is replaced with
  50. ;     #(>> define-record-type record-ref)
  51.  
  52. (define (name->qualified name env)
  53.   (if env
  54.       (if (generated? name)
  55.       (if (same-denotation? (lookup env name)
  56.                 (lookup env (generated-symbol name)))
  57.           (generated-symbol name)    ;+++
  58.           (make-qualified
  59.            (let recur ((name (generated-parent-name name)))
  60.          (if (generated? name)
  61.              (let ((parent (generated-parent-name name)))
  62.                (if (let ((b1 (lookup env name))
  63.                  (b2 (lookup env parent)))
  64.                  (or (same-denotation? b1 b2)
  65.                  (and (binding? b1)
  66.                       (binding? b2)
  67.                       (let ((s1 (binding-static b1))
  68.                         (s2 (binding-static b2)))
  69.                     (and (transform? s1)
  70.                          (transform? s2)
  71.                          (eq? (transform-env s1)
  72.                           (transform-env s2)))))))
  73.                (recur parent) ;+++
  74.                `#(>> ,(recur parent)
  75.                  ,(generated-symbol name))))
  76.              name))
  77.            (generated-symbol name)))
  78.       name)
  79.       (desyntaxify name)))
  80.  
  81. ; lambda, let-syntax, letrec-syntax...
  82.  
  83. (define-schemifier 'letrec syntax-type
  84.   (lambda (node env)
  85.     (let ((form (node-form node)))
  86.       `(letrec ,(map (lambda (spec)
  87.                `(,(car spec) ,(schemify1 (cadr spec) env)))
  88.              (cadr form))
  89.      ,@(map (lambda (f) (schemify1 f env))
  90.         (cddr form))))))
  91.  
  92. (define (schemify-sexp thing env)
  93.   (cond ((name? thing)
  94.      (name->qualified thing env))
  95.     ((pair? thing)
  96.      (let ((x (schemify-sexp (car thing) env))
  97.            (y (schemify-sexp (cdr thing) env)))
  98.        (if (and (eq? x (car thing))
  99.             (eq? y (cdr thing)))
  100.            thing            ;+++
  101.            (cons x y))))
  102.     ((vector? thing)
  103.      (let ((new (make-vector (vector-length thing) #f)))
  104.        (let loop ((i 0) (same? #t))
  105.          (if (>= i (vector-length thing))
  106.          (if same? thing new)    ;+++
  107.          (let ((x (schemify-sexp (vector-ref thing i) env)))
  108.            (vector-set! new i x)
  109.            (loop (+ i 1)
  110.              (and same? (eq? x (vector-ref thing i)))))))))
  111.     (else thing)))
  112.  
  113.  
  114. ; Qualified names
  115.  
  116. (define (make-qualified transform-name sym)
  117.   (vector '>> transform-name sym))
  118.  
  119. (define (qualified? thing)
  120.   (and (vector? thing)
  121.        (= (vector-length thing) 3)
  122.        (eq? (vector-ref thing 0) '>>)))
  123.  
  124. (define (qualified-parent-name q) (vector-ref q 1))
  125. (define (qualified-symbol q) (vector-ref q 2))
  126.